home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
Plurals
/
Modules
/
plisp.em
< prev
next >
Wrap
Lisp/Scheme
|
1992-06-02
|
16KB
|
601 lines
(defmodule plisp (standard0 plural plisp-ll) ()
(setq MP-Config 512)
(setq GC-TOP (mp-sb-ref))
(defclass xec ()
((context
initarg context
reader context)
(offset
initarg offset
reader offset))
constructor (allocate-xec context offset)
predicate xecp)
(defun make-xec (c o)
(become-strange (allocate-xec c o)))
(defmethod generic-prin ((p xec) str)
(format str "#x(")
(mp-print (context p) (offset p) str)
(format str ")")
p)
(defmethod generic-write ((p xec) str)
(format str "#x(")
(mp-print (context p) (offset p) str)
(format str ")")
p)
(defclass mp-object ()
((contexts
initarg contexts
reader contexts)
(offsets
initarg offsets
accessor offsets)
(index
initarg index
accessor index)
(shape
initarg shape
accessor shape))
predicate mp-object-p)
(defclass field (mp-object)
()
constructor (allocate-field contexts offsets index shape)
predicate fieldp)
(defun make-field (c o i s)
(become-strange (allocate-field c o i s)))
(defmethod generic-prin ((f field) str)
(format str "#F(")
(mapcar (lambda (c o) (mp-print c o str)) (contexts f) (offsets f))
(format str ")")
f)
(defmethod generic-write ((f field) str)
(format str "#F(")
(mapcar (lambda (c o) (mp-print c o str)) (contexts f) (offsets f))
(format str ")")
f)
; if something is not a partial paralation, it is a global paralation,
; we can use the same one I think, as long as operations are independent.
; which I think they are though this will run into trouble with
; recursive elwises.
(setq MP-Context (mp-make-context MP-Config))
(setq MP-Offsets (cons (mp-make-plural MP-Context) ()))
(setq MP-Nil (mp-bang MP-Context ()))
(setq GC-Protect (list (make-xec MP-Context (car MP-Offsets))
(make-xec MP-Context MP-Nil)))
(defun number-segment (ctxt ofst start size)
(format t "Renumber: start=~a size=~a\n" start size)
(labels ((recurse (i)
(if (< i (- size start)) (recurse (+ i 1)) ())
(mp-set ctxt ofst i (+ start i))))
(recurse 0)))
(number-segment MP-Context (car MP-Offsets) 0 MP-Config)
(defun number-segment (ctxt ofst start size)
(mp-bin-op ctxt (car MP-Offsets)
(mp-bang ctxt (- start (cm-start ctxt))) 610))
(setq VMP-Config MP-Config)
(setq PMP-Config (mp-bang MP-Context MP-Config))
(setq GC-Protect (cons (make-xec MP-Context PMP-Config) GC-Protect))
(defun enough-virtual-pes-p
(required) (< required (+ VMP-Config MP-Config)))
(defun more-processors (required)
(labels ((find-last (offsets)
(if (cdr offsets) (find-last (cdr offsets))
((setter cdr) offsets (make-rest (car offsets)))))
(make-rest (offset)
(if (enough-virtual-pes-p required) ()
(let ((new-ofst (mp-bin-op MP-Context offset PMP-Config 610)))
(setq VMP-Config (+ VMP-Config MP-Config))
(setq GC-Protect (cons (make-xec MP-Context new-ofst)
GC-Protect))
(cons new-ofst (make-rest new-ofst))))))
(find-last MP-Offsets)))
(defun allocate-processors (required)
(if (not (enough-virtual-pes-p required)) (more-processors required) ())
(labels ((list-of-ctxts (allocated)
(if (>= (+ allocated MP-Config) required)
(list (mp-make-context (- required allocated)))
(cons MP-Context (list-of-ctxts (+ allocated MP-Config)))))
(list-of-ofsts (contexts offsets allocated)
(cond
((null contexts) ())
((eq (car contexts) MP-Context)
(cons (car offsets)
(list-of-ofsts (cdr contexts) (cdr offsets)
(+ allocated MP-Config))))
(t (list (number-segment (car contexts)
(mp-make-plural (car contexts))
allocated required))))))
(let* ((contexts (list-of-ctxts 0))
(offsets (list-of-ofsts contexts MP-Offsets 0)))
(make-field contexts offsets () ()))))
(defcondition illegal-operation ())
(defun make-paralation (size)
(if (< size 1) (error "Attempt to create empty paralation" illegal-operation)
(let ((new-field (allocate-processors size)))
((setter index) new-field new-field)
new-field)))
(defun field-ref (f i)
(let ((list-index (/ i MP-Config)))
(mp-ref (list-ref (contexts f) list-index)
(list-ref (offsets f) list-index) (remainder i MP-Config))))
((setter setter) field-ref (lambda (f i v)
(let ((list-index (/ i MP-Config)))
(mp-set (list-ref (contexts f) list-index)
(list-ref (offsets f) list-index) (remainder i MP-Config) v)
f)))
(defun field-length (f)
(let ((ll (list-length (contexts f))))
(+ (* (if (> ll 1) (- ll 1) 0) MP-Config)
(mp-length (list-ref (contexts f) (- ll 1))))))
; This implementation of paralation lisp is based on an existing
; version of CM Lisp, in which most of the parallel operations are done
; in a global context called everywhere. I am going to attempt to use
; a similar system, but when performing a parallel operation we set
; the "global" context, THE-CONTEXT, to be that of the current paralation
; Primitives
; ==========
(p-1-fn mp-un-op negate 620)
(p-1-fn mp-un-op abs 621)
(p-2-fn mp-eq eq ())
(p-2-fn mp-cons cons ())
(p-1-fn mp-car car ())
(p-1-fn mp-cdr cdr ())
(p-1-fn mp-make-vector make-vector())
(p-1-fn mp-vector-length vector-length ())
(p-2-fn mp-vector-ref vector-ref ())
(p-1-fn mp-test consp 2)
(p-1-fn mp-test intp 1)
(p-1-fn mp-test floatp 4)
(p-1-fn mp-test vectorp 3)
(p-2-fn mp-bin-op binary-plus 610)
(p-2-fn mp-bin-op + 610)
(p-2-fn mp-bin-op binary-difference 611)
(p-2-fn mp-bin-op - 611)
(p-2-fn mp-bin-op binary-times 613)
(p-2-fn mp-bin-op * 613)
(p-2-fn mp-bin-op binary-divide 612)
(p-2-fn mp-bin-op / 612)
(p-2-fn mp-rel-op binary-gt 651)
(p-2-fn mp-rel-op > 651)
(p-2-fn mp-rel-op binary-lt 650)
(p-2-fn mp-rel-op < 650)
(p-2-fn mp-bin-op remainder 614)
(p-0-fn mp-random c-rand ())
(p-2-fn mp-and and ())
(p-2-fn mp-or or ())
(p-1-fn mp-not not ())
(p-2-fn mp-assign setq ())
(p-3-set mp-vector-set vector-ref ())
(p-2-set mp-rplac-a car ())
(p-2-set mp-rplac-d cdr ())
; There are a few lisp functions who work in parallel - this is a hack!
((setter table-ref) pfun-table 'progn (cons 'progn ()))
; Elwise
; ======
; A few everywhere things are still useful
(setq The-Context 'none)
(defun Set-The-Context (v) (setq The-Context v))
(defun rewire (form)
(cond
((consp form)
(cond
((eq (car form) 'quote) (list 'mp-bang 'The-Context form))
((eq (car form) (car function-name)) (cons (cadr function-name)
(rewire (cdr form))))
((eq (car form) 'if) (elwise-if (cadr form) (caddr form) (cadddr form)))
((eq (car form) 'setter) (car (get-psetter (cadr form))))
((eq (car form) 'cond) (cons 'let (cons '((cond-result
(mp-make-plural The-Context)))
(cons '(mp-if The-Context (mp-bang The-Context t))
(rewire-cond (cdr form))))))
((eq (car form) 'lambda) (rewire-lambda (cdr form)))
((eq (car form) 'let) (rewire-let (cdr form)))
(t (cons (if (car form) (rewire (car form)) MP-Nil)
(rewire (cdr form))))))
((numberp form) (list 'mp-bang 'The-Context form))
((memq form arg-list) form)
((get-pfun form) (car (get-pfun form)))
((null form) ())
(t (list 'mp-bang 'The-Context form))))
(defun rewire-cond (form)
(if (null form) '((mp-fi The-Context) cond-result)
(cons
(list 'if (list 'mp-if 'The-Context (rewire (caar form)))
(list 'mp-assign 'The-Context
'cond-result(rewire (cadar form))) ())
(cons '(mp-file The-Context)
(rewire-cond (cdr form))))))
(defun rewire-let (form)
(let ((old-arg-list arg-list))
(setq arg-list (append (mapcar car (car form)) arg-list))
(let ((r-form (list 'let (mapcar (lambda (n-f-p)
(cons (car n-f-p)
(rewire (cdr n-f-p))))
(car form)) (cons 'progn (mapcar rewire
(cdr form))))))
(setq arg-list old-arg-list)
r-form)))
(defun rewire-lambda (form)
(let ((old-arg-list arg-list))
(setq arg-list (append (car form) arg-list))
(let ((r-form (list 'lambda (car form) (rewire (cadr form)))))
(setq arg-list old-arg-list)
r-form)))
(defun elwise-if (bool then else)
(let ((then (if then (rewire then) MP-Nil))
(else (if else (rewire else) MP-Nil)))
(list 'let '((if-result (mp-make-plural The-Context)))
(list 'if (list 'mp-if 'The-Context (rewire bool))
(list 'mp-assign 'The-Context 'if-result then) ())
(list 'if (list 'mp-else 'The-Context)
(list 'mp-assign 'The-Context 'if-result else) ())
'(mp-fi The-Context)
'if-result)))
(defun eval-arg-list (arg-form)
(if (null arg-form) (list (list 'the-contexts
(list 'contexts (car arg-list)))
(list 'the-index (list 'index (car arg-list)))
(list 'the-shape (list 'shape (car arg-list)))
'(the-offsets (mapcar mp-make-plural the-contexts))
'(the-result (make-field the-contexts the-offsets the-index the-shape)))
(if (consp (car arg-form))
(progn
(setq arg-list (cons (caar arg-form) arg-list))
(cons (car arg-form) (eval-arg-list (cdr arg-form))))
(progn
(setq arg-list (cons (car arg-form) arg-list))
(eval-arg-list (cdr arg-form))))))
(defun get-offsets (arg-list)
(mapcar (lambda (f) (list `offsets f)) arg-list))
(defmacro elwise (arg-form body)
(setq arg-list ())
(setq function-name '(none))
`(let* ,(eval-arg-list arg-form)
(mapcar (lambda ,(cons `the-context
(cons 'result-ofst arg-list))
(let ((tmp-pspace (mp-ps-ref)))
(mp-sb-set tmp-pspace)
(Set-The-Context the-context)
(mp-assign The-Context result-ofst
,(if body (rewire body)
(list 'mp-bang 'The-Context ())))
(mp-sb-set GC-TOP)
(mp-ps-set tmp-pspace)
result-ofst))
,@(cons `the-contexts (cons `the-offsets
(get-offsets arg-list))))
the-result))
; to add primitives, particularly recursive primitives
(defmacro depfun (name args body)
(setq arg-list args)
(setq function-name (list name (make-pfun-name name)))
(add-pfun name (cadr function-name) args)
`(progn (defun ,(cadr function-name) ,args ,(rewire body))
(export ,(cadr function-name))))
(defclass mapping (mp-object)
()
constructor (make-mapping contexts offsets index shape)
predicate mappingp)
(defun allocate-mapping (c o i s)
(become-strange (make-mapping c o i s)))
; It seems a non-trivial task to make this GC safe
(defun match (dest from)
(let ((result (allocate-mapping
(contexts dest) (mapcar (lambda (d-c)
(mapcar (lambda (f-c)
(mp-make-plural d-c))
(contexts from)))
(contexts dest))
(index dest) (shape dest)))
(tmp-pspace (mp-ps-ref)))
(mp-sb-set tmp-pspace)
(labels ((seg-match (d-ctxt d-ofst r-ofsts ctxts ofsts)
(if (null ctxts) ()
(progn
(mp-assign d-ctxt (car r-ofsts)
(mp-match d-ctxt d-ofst
(car ctxts) (car ofsts)))
(seg-match d-ctxt d-ofst (cdr r-ofsts)
(cdr ctxts) (cdr ofsts))))))
(mapcar (lambda (c o r)
(seg-match c o r (contexts from) (offsets from)))
(contexts dest) (offsets dest) (offsets result))
(mp-ps-set tmp-pspace)
(mp-sb-set GC-TOP)
result)))
; Don't think this needs any protection the mpl protection (which I have yet to
; put in should be sufficient
(defun ll-move (data map)
(let ((initial (mapcar mp-make-plural (contexts map))))
(mapcar
(lambda (m-ctxt m-ofsts i-ofst)
(mapcar (lambda (d-ctxt d-ofst m-ofst)
(mp-move d-ctxt d-ofst m-ctxt m-ofst i-ofst))
(contexts data) (offsets data) m-ofsts))
(contexts map) (offsets map) initial)
initial))
(defmacro move (data map with default)
`(l-move ,data ,map ,(if (not (consp with)) (car (get-pfun with))
(progn
(setq arg-list (cadr with))
(list 'lambda arg-list (rewire (caddr with)))))
,default))
(defun l-move (data map p-with default)
(labels ((recurse (l-ofst cdrl-ofst r-ofst)
(if (mp-if The-Context cdrl-ofst)
(mp-assign The-Context r-ofst
(p-with (mp-car The-Context l-ofst)
(recurse cdrl-ofst
(mp-cdr The-Context cdrl-ofst)
r-ofst))) ())
(mp-else The-Context)
(mp-assign The-Context r-ofst (mp-car The-Context l-ofst))
(mp-fi The-Context)
r-ofst))
(let ((result (make-field (contexts map)
(mapcar mp-make-plural (contexts map))
(index map) (shape map))))
(mapcar (lambda (ctxt ofst r-ofst)
(let ((tmp-pspace (mp-ps-ref)))
(mp-sb-set tmp-pspace)
(Set-The-Context ctxt)
(mp-if ctxt ofst)
(recurse ofst (mp-cdr The-Context ofst) r-ofst)
(mp-else ctxt)
(mp-assign ctxt r-ofst (mp-bang ctxt default))
(mp-fi ctxt)
(mp-sb-set GC-TOP)
(mp-ps-set tmp-pspace)
r-ofst))
(contexts map) (ll-move data map) (offsets result))
result)))
(defun get (direction f default)
(let ((map (vector-ref (shape f) direction))
(result (make-field (contexts f) (mapcar mp-make-plural (contexts f))
(index f) (shape f))))
(mapcar (lambda (c o r-o)
(let ((tmp-pspace (mp-ps-ref)))
(mp-sb-set tmp-pspace)
(mp-if c o) (mp-assign c r-o (mp-car c o))
(mp-else c) (mp-assign c r-o (mp-bang c default))
(mp-fi c)
(mp-sb-set GC-TOP)
(mp-ps-set tmp-pspace) r-o))
(contexts f) (ll-move f map) (offsets result))
result))
(defun enum-ll (bool-f)
(let ((result (elwise (bool-f) (if bool-f 1 0)))
(tmp-pspace (mp-ps-ref)))
(labels ((recurse (c-s o-s s)
(if (null c-s) ()
(progn
(mp-assign (car c-s) (car o-s)
(mp-bin-op (car c-s)
(mp-scan-op (car c-s)
(car o-s) 610)
(mp-bang (car c-s) s) 610))
(recurse (cdr c-s) (cdr o-s)
(mp-ref (car c-s) (car o-s)
(- (mp-length (car c-s)) 1)))))))
(mp-sb-set tmp-pspace)
(recurse (contexts result) (offsets result) 0)
(mp-ps-set tmp-pspace)
(mp-sb-set GC-TOP)
result)))
(defun enum (bool-f)
(elwise (bool-f (new (enum-ll bool-f))) (if bool-f (- new 1) ())))
(defun choose (bool-f)
(let ((tmp (enum-ll bool-f)))
(match (make-paralation (field-ref tmp (- (field-length bool-f) 1)))
(elwise (tmp bool-f) (if bool-f (- tmp 1) ())))))
(defun count (bool-f)
(field-ref (enum-ll bool-f) (- (field-length bool-f) 1)))
(defun position (f o)
(let* ((tmp (elwise (f (i (index f))) (if (eq f o) i ())))
(tmp-pspace (mp-ps-ref))
(t-o (progn (mp-sb-set tmp-pspace) (mp-bang MP-Context 32768))))
(labels ((recurse (c-s o-s)
(cond
((null c-s) ())
((not (mp-if (car c-s) (car o-s)))
(progn (mp-fi (car c-s))
(recurse (cdr c-s) (cdr o-s))))
(t (progn
(mp-assign (car c-s) t-o (car o-s))
(mp-fi (car c-s))
(mp-ref (car c-s) (mp-scan-op (car c-s) t-o 661)
(- (mp-length (car c-s)) 1)))))))
(let ((result (recurse (contexts f) (offsets tmp))))
(mp-sb-set GC-TOP)
(mp-ps-set tmp-pspace)
result))))
; Vref
; We want to create a map which will shift everything left in the global
; context, this can be used by all other contexts to the same effect
(export depfun elwise match move make-paralation field-ref contexts offsets
index shape make-field Set-The-Context The-Context GC-TOP position
l-move choose enum count get fieldp field-length
allocate-xec rewire)
)